home *** CD-ROM | disk | FTP | other *** search
/ Technotools / Technotools (Chestnut CD-ROM)(1993).ISO / lang_oth / ada / augusta.bas < prev    next >
BASIC Source File  |  1986-06-09  |  25KB  |  468 lines
  1. 1 ' **************************************
  2. 2 ' *                     *
  3. 3 ' *   Augusta.bas - a public domain    *
  4. 4 ' *   subset of the US Department of   *
  5. 5 ' *   Defense computer language Ada.   *
  6. 6 ' *                     *
  7. 7 ' **************************************
  8. 8 '
  9. 10 '
  10. 100 '
  11. 1000 DEFINT A-Z:CLS:KEY OFF:PRINT"Augusta(tm) Compiler v1.1A":PRINT"(C) Copyright 1983 by Computer Linguistics":PRINT"All rights reserved."
  12. 1003 DIM MAP(26),KEYWD$(33),S$(100),TY(20),B$(3),B(3),S(500)
  13. 1010 PRINT:PRINT"Initializing ...":GOSUB 1780:GOSUB 1110:SI=1:PRINT:INPUT"Source file ? ",S$:GOSUB 1230
  14. 1020 INPUT"Code file ? ",C$:OPEN"R",#1,C$,128:CLOSE 1:KILL C$
  15. 1040 INPUT"Listing (Y/CR)? ",T1$:OPEN"R",#1,C$,128:R0=16:M0=R0:IF T1$="Y" THEN PLST=-1:LPRINT LP$;
  16. 1050 GOSUB 1290:GOSUB 1400:PRINT FRE("");" Bytes for symbols":GOSUB 1980
  17. 1060 PUT #1,R0:FIELD #1,2 AS T1$,2 AS T2$,2 AS T3$,2 AS D$,2 AS S$
  18. 1070 LSET T1$=MKI$(GC):LSET T2$=MKI$(M0):LSET T3$=MKI$(PROC):LSET D$=MKI$(0):LSET S$=MKI$(1113)
  19. 1080 PUT #1,1:FIELD #1,128 AS D$:FOR I=1 TO MB:IF B(I)<>0 AND B(I)<>R0 THEN LSET D$=B$(I):PUT #1,B(I)
  20. 1090 NEXT I:CLOSE 1:PRINT:PRINT"Compiled OK":PRINT LN;" LINES. ";GC-1920;" bytes":GOTO 32767
  21. 1110 ' ********* Init
  22. 1120 QUOTE$=CHR$(34):LEXCH$=ALF$+DIG$+" @*+=-<>/:;')(,"+QUOTE$+".#!"+CHR$(3)+CHR$(96)+CHR$(9):CLST=-1
  23. 1130 SQUOTE=0:EOL=1:C=2:LP=3:RP=4:MUL=5:DIV=6:ADD=7:SUBT=8:LES=9:LEQ=10:GT=11:GEQ=12:EQ=13:NEQ=14:BAR=15:ID=16
  24. 1135 SC=17:COMMA=18:SEMICOLON=19:COLON=20:EQGT=21:COLONEQ=22:DOT=23:DOTDOT=24:CH=25:AT=26
  25. 1140 KAND=27:KARRAY=28:KBEGIN=29:KCASE=30:KCONST=31:KDECLARE=32:KELSE=33:KELSEIF=34:KEND=35:KEXIT=36:KFOR=37:KFUNC=38:KIF=39
  26. 1145 KIN=40:KIS=41:KLOOP=42:KLAST=43:KLEN=44:KMOD=45:KNOT=46:KNULL=47:KOF=48:KOR=49:KOTHERS=50:KOUT=51
  27. 1150 KPRAGMA=52:KPROC=53:KRET=54:KREVERSE=55:KTHEN=56:KWHEN=57:KWHILE=58
  28. 1160 ADDOP$=CHR$(ADD)+CHR$(SUBT):MULOP$=CHR$(MUL)+CHR$(DIV)+CHR$(KMOD):LOGICALOP$=CHR$(KAND)+CHR$(KOR)
  29. 1165 UNARYOP$=CHR$(ADD)+CHR$(SUBT)+CHR$(KNOT):RELOP$=CHR$(LES)+CHR$(LEQ)+CHR$(GT)+CHR$(GEQ)+CHR$(EQ)+CHR$(NEQ)
  30. 1170 DECLPART$=CHR$(ID)+CHR$(KPROC)+CHR$(KFUNC)+CHR$(KPRAGMA)
  31. 1180 STMT$=CHR$(KWHILE)+CHR$(KFOR)+CHR$(KLOOP)+CHR$(KDECLARE)+CHR$(KBEGIN)+CHR$(KEXIT)+CHR$(KRET)+CHR$(KIF)
  32. 1185 STMT$=STMT$+CHR$(KCASE)+CHR$(KNULL)+CHR$(ID)+CHR$(PRAGMA)
  33. 1190 LN=1:EOI=0:LL=0:CPROC=0:PROC=0:GC=1920:VLOC=VARPTR(V):VLOC1=VLOC+1:TSTR=0:TINT=1:TCHR=2:TBOL=4:FMSZ=14
  34. 1200 PLDCI=1:PLDL=2:PLLA=3:PLDB=4:PLDO=5:PLAO=6:PDUP=7:PLOD=8:PLDA=9:PPOP=10:PSTO=11:PSINDO=12:PLCA=13:PSAS=14:PAND=16
  35. 1205 POR=17:PNOT=18:PADI=19:PNGI=20:PSBI=21:PMPI=22:PDVI=23:PIND=24:PEQUI=25:PNEQI=26:PLEQI=27:PSLDC=61:PINCL=80:PDECL=81
  36. 1210 PLESI=28:PGEQI=29:PGTRI=30:PEQUSTR=31:PNEQSTR=32:PLEQSTR=33:PLESSTR=34:PGEQSTR=35:PGTRSTR=36:PUJP=37:PFJP=38:PXJP=39
  37. 1215 PCLP=40:PCGP=41:PCSP=42:PRET=43:PMODI=45:PCIP=46:PRNP=47:PEOP=15:PSLDCN1=63:PIXA=48
  38. 1217 PSLDO=57:PSLAO=58:PSLLA=59:PSLDLO=49:PSLDL=60
  39. 1220 RETURN
  40. 1230 '********** Open Source
  41. 1240 SI=SI+1:OPEN"I",#SI,S$:RETURN
  42. 1250 '********** Convert to UPPERCASE
  43. 1260 IF INSTR(LC$,CH$) THEN CH$=CHR$(ASC(CH$)-32)
  44. 1270 RETURN
  45. 1280 '********** GetLine
  46. 1290 LN=LN+1:IF EOF(SI) THEN CLOSE SI:SI=SI-1:IF SI>1 AND PLST THEN LPRINT TAB(26);"* End of INCLUDE"
  47. 1300 IF SI=1 THEN EOI=-1:RETURN
  48. 1310 LINE INPUT #SI,BUF$
  49. 1320 IF PLST=0 THEN GOTO 1330 ELSE LPRINT USING"##### #### ###### ###### ";LN,CPROC,CP,OFST;:LPRINT LEFT$(BUF$,54)
  50. 1325 IF (LN MOD 60)=0 THEN LPRINT CHR$(12);:LPRINT:LPRINT
  51. 1330 IF CLST<>0 THEN PRINT BUF$ ELSE IF (LN AND 63)=63 THEN PRINT LN;"..."
  52. 1340 IF LEN(BUF$)=0 THEN 1290 ELSE BUF$=BUF$+CHR$(3):B=1:WHILE MID$(BUF$,B,1)=" ":B=B+1:WEND:CH$=MID$(BUF$,B,1):B=B+1:RETURN
  53. 1360 '********** GetCh
  54. 1370 LSET CH$=MID$(BUF$,B,1):B=B+1:RETURN
  55. 1380 B=B+1
  56. 1390 RETURN
  57. 1400 '********** GetSym
  58. 1410 OLDB=B:GOSUB 1250:I=INSTR(LEXCH$,CH$):IF I=0 THEN E=1:GOTO 5020
  59. 1420 IF I<27 THEN GOSUB 1460:GOTO 1430
  60. 1423 IF I<42 THEN ON I-26 GOSUB 1500,1500,1500,1500,1500,1500,1500,1500,1500,1500,1700,1770,1720,1520,1600:GOTO 1430
  61. 1427 ON I-41 GOSUB 1530,1620,1640,1660,1680,1540,1750,1570,1560,1550,1730,1580,1695,1710,1450,1440,1775
  62. 1430 IF EOI THEN E=12:GOTO 5020 ELSE IF OLDB=B THEN 1410 ELSE LSET TT$=CHR$(T):RETURN
  63. 1440 T=SQUOTE:GOSUB 1360:RETURN
  64. 1450 GOSUB 1290:OLDB=B:RETURN
  65. 1460 S$="":WHILE INSTR(AN$,CH$):IF CH$<>"_" THEN S$=S$+CH$
  66. 1470 GOSUB 1370:GOSUB 1260:WEND:IF LEN(S$)>8 THEN S$=LEFT$(S$,8)
  67. 1480 ID$=S$+SPACE$(8-LEN(S$)):GOSUB 1890:RETURN
  68. 1490 '********** Digits
  69. 1500 TN=0:I1=10
  70. 1510 WHILE INSTR(HDIG$,CH$):TN=TN*I1+INSTR(HDIG$,CH$)-1:GOSUB 1360:WEND
  71. 1515 IF CH$="#" THEN I1=TN:TN=0:GOSUB 1360:GOTO 1510 ELSE T=C:RETURN
  72. 1520 T=ADD:GOSUB 1360:RETURN
  73. 1530 T=SUBT:GOSUB 1360:IF CH$="-" THEN GOSUB 1280:OLDB=B:RETURN ELSE RETURN
  74. 1540 T=SEMICOLON:GOSUB 1360:RETURN
  75. 1550 T=COMMA:GOSUB 1360:RETURN
  76. 1560 T=LP:GOSUB 1360:RETURN
  77. 1570 T=RP:GOSUB 1360:RETURN
  78. 1580 T=DOT:GOSUB 1360:IF CH$="." THEN T=DOTDOT:GOSUB 1360
  79. 1590 RETURN
  80. 1600 GOSUB 1360:IF CH$=">" THEN T=EQGT:GOSUB 1360 ELSE T=EQ
  81. 1610 RETURN
  82. 1620 GOSUB 1360:IF CH$="=" THEN T=LEQ:GOSUB 1360 ELSE T=LES
  83. 1630 RETURN
  84. 1640 GOSUB 1360:IF CH$="=" THEN T=GEQ:GOSUB 1360 ELSE T=GT
  85. 1650 RETURN
  86. 1660 GOSUB 1360:IF CH$="=" THEN T=NEQ:GOSUB 1360 ELSE T=DIV
  87. 1670 RETURN
  88. 1680 GOSUB 1360:IF CH$="=" THEN T=COLONEQ:GOSUB 1360 ELSE T=COLON
  89. 1690 RETURN
  90. 1695 T=BAR:GOSUB 1360:RETURN
  91. 1700 WHILE CH$=" ":LSET CH$=MID$(BUF$,B,1):B=B+1:WEND:OLDB=B:RETURN
  92. 1710 T=BAR:GOSUB 1360:RETURN
  93. 1720 T=MUL:GOSUB 1360:RETURN
  94. 1730 I1=INSTR(B,BUF$,QUOTE$):IF I1=0 THEN E=10:GOTO 5020
  95. 1740 S$=MID$(BUF$,B,I1-B):T=SC:B=I1+1:GOSUB 1360:RETURN
  96. 1750 GOSUB 1360:GOSUB 1360:IF CH$<>"'" THEN E=11:GOTO 5020
  97. 1760 GOSUB 1360:GOSUB 1930:TN=ASC(MID$(S$,2,1)):T=CH:RETURN
  98. 1770 T=AT:GOSUB 1360:RETURN
  99. 1775 GOSUB 1360:OLDB=B:RETURN
  100. 1780 '********** Read Data
  101. 1790 CH$=" ":B=0:LB=0:AN$=CH$:LC$=CH$:S$=CH$:T=0:T0=0:X=0:SP=0:TSP=0:LEXCH$=S$:CP=0:CB=0:W=0:I=0:R2=0:R1=0:T3=0:R0=16
  102. 1795 D$=S$:LOC1=0:LOC2=0:V=0:VLOC=0:VLOC1=0:TN=0:TT$=S$:HASH=0:ID$=S$:BUF$=S$:T1=0:T2=0
  103. 1800 NKEY=33:SSP=1:MB=3:FOR I=0 TO MB:B$(I)=SPACE$(128):B(I)=0:NEXT I
  104. 1820 OPEN"I",#1,"keywords.txt":LINE INPUT #1,LC$:T1=1:WHILE T1>0:INPUT #1,T1:LP$=LP$+CHR$(T1):WEND
  105. 1830 INPUT #1,DIG$,HDIG$,ALF$,LC$,AN$
  106. 1840 FOR I=1 TO 26:INPUT #1,MAP(I):NEXT I
  107. 1850 I=1:INPUT #1,ID$,TYPE,KIND,PINFO,CONST,OBJSZ,ADDR,LL:IF ID$<>"*END*" THEN ID$=ID$+SPACE$(8-LEN(ID$)):GOSUB 3850:GOTO 1850
  108. 1860 IF EOF(1) THEN 1880 ELSE INPUT #1,T$:IF LEN(T$)>8 THEN T$=LEFT$(T$,8)
  109. 1870 T$=T$+SPACE$(8-LEN(T$)):KEYWD$(I)=T$:I=I+1:GOTO 1860
  110. 1880 CLOSE 1:KEYWD$(0)=" ":KEYWD$(NKEY)=" ":RETURN
  111. 1890 '********** LookupKeyword
  112. 1900 HASH=MAP(INSTR(ALF$,LEFT$(ID$,1)))
  113. 1910 IF KEYWD$(HASH)=ID$ THEN T=HASH+26 ELSE IF ASC(KEYWD$(HASH))<>ASC(ID$) THEN T=ID ELSE HASH=HASH+1:GOTO 1910
  114. 1920 RETURN
  115. 1930 '********** Get S$
  116. 1940 S$=MID$(BUF$,OLDB-1,B-OLDB):RETURN
  117. 1950 IF T0=T THEN RETURN
  118. 1955 E=4:GOSUB 5110:PRINT"Reenter+ ";:LINE INPUT T$:BUF$=LEFT$(BUF$,B-1)+T$+CHR$(3):GOSUB 1360:GOSUB 1400:GOTO 1950
  119. 1960 IF T0=T THEN GOSUB 1400:RETURN ELSE GOSUB 1950:GOSUB 1400:RETURN
  120. 1970 '********** Compilation
  121. 1980 GOSUB 2770
  122. 1990 IF T=KPROC THEN GOSUB 1400:GOSUB 2010:T0=SEMICOLON:GOSUB 1950
  123. 2000 RETURN
  124. 2010 '********** Parse Proc
  125. 2020 GOSUB 5200
  126. 2030 KIND=2:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:GOSUB 1400
  127. 2040 OFST=-FMSZ:IF T=KIS THEN 2060
  128. 2050 GOSUB 2100:T0=KIS:GOSUB 1950
  129. 2060 '********** Is
  130. 2070 X=-(OFST+FMSZ):GOSUB 4280:GOSUB 1400:OFST=0:MXOF=0:GOSUB 2440:W=PRET:GOSUB 3990:GOSUB 5300:RETURN
  131. 2100 '********** ProcFormalPart
  132. 2110 T2$="":T0=LP:GOSUB 1960
  133. 2120 GOSUB 2160:IF T=SEMICOLON THEN GOSUB 1400:GOTO 2120
  134. 2130 T0=RP:GOSUB 1960:FOR I=OFST TO-FMSZ-2 STEP 2:T1$=LEFT$(T2$,17):T2$=MID$(T2$,18):IF LEN(S$(SSP))+17)>255 THEN SSP=SSP+1
  135. 2140 S$(SSP)=LEFT$(T1$,14)+MKI$(I)+RIGHT$(T1$,1)+S$(SSP):NEXT I
  136. 2150 RETURN
  137. 2160 '********** ProcParamDecl
  138. 2170 T1$=""
  139. 2180 T0=ID:GOSUB 1950:T1$=T1$+ID$:GOSUB 1400
  140. 2190 IF T=COMMA THEN GOSUB 1400:GOTO 2180
  141. 2200 T0=COLON:GOSUB 1960:P1=1:IF T=KOUT THEN P1=2:GOSUB 1400:GOTO 2220
  142. 2210 IF T=KIN THEN GOSUB 1400
  143. 2220 GOSUB 2250:PINFO=P1
  144. 2230 WHILE LEN(T1$)>0:T2$=T2$+LEFT$(T1$,8)+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(0)+CHR$(LL)
  145. 2235 T1$=MID$(T1$,9):OFST=OFST-2:WEND
  146. 2240 RETURN
  147. 2250 '********** SubtypeIdentificationUnit
  148. 2260 GOSUB 3890:IF KIND<>4 THEN E=8:GOTO 5020 ELSE IF PINFO=0 THEN KIND=1 ELSE KIND=5
  149. 2280 IF TYPE<>0 THEN GOSUB 1400:RETURN
  150. 2285 GOSUB 2300:IF OBJSZ>255 THEN E=15:GOTO 5020 ELSE RETURN
  151. 2290 '********** Get C
  152. 2293 IF T<>ID THEN GOTO 2297 ELSE T8=TYPE:T3=KIND:T4=PINFO:T5=CONST:T6=OBJSZ:T7=LL
  153. 2294 GOSUB 3890:IF KIND=0 AND TYPE=1 THEN T=C:T2=CONST
  154. 2295 TYPE=T8:KIND=T3:PINFO=T4:CONST=T5:OBJSZ=T6:LL=T7
  155. 2297 T0=C:GOSUB 1960:RETURN
  156. 2300 '********** ObjSz
  157. 2310 GOSUB 1400:IF T<>LP THEN 2330 ELSE GOSUB 1400
  158. 2320 GOSUB 2290:OBJSZ=TN+1:T0=RP:GOSUB 1960
  159. 2330 RETURN
  160. 2340 '********** ParseFunc
  161. 2350 GOSUB 5200:KIND=3:PROC=PROC+1:CPROC=PROC:ADDR=PROC:X=ADDR:GOSUB 4280:GOSUB 3850:X=SSP:GOSUB 4280:X=LEN(S$(SSP))
  162. 2355 GOSUB 4280:GOSUB 1400
  163. 2370 OFST=-FMSZ:IF T=LP THEN GOSUB 2100
  164. 2380 T0=KRET:GOSUB 1960:GOSUB 2250:GOSUB 4300:T2=X:GOSUB 4300:T1=X:T3=LEN(S$(T1)):IF KIND<>5 OR OBJSZ<>2 THEN E=16:GOTO 5020
  165. 2385 S$(T1)=LEFT$(S$(T1),T3-T2+8)+CHR$(TYPE)+MID$(S$(T1),T3-T2+10)
  166. 2400 T0=KIS:GOSUB 1960
  167. 2410 X=-(OFST+FMSZ):GOSUB 4280:OFST=0:MXOF=0:GOSUB 2440:GOSUB 5300:RETURN
  168. 2440 '********** BodyPart
  169. 2450 IF INSTR(DECLPART$,TT$) THEN GOSUB 2480
  170. 2460 CB=GC:CP=0:GOSUB 2790
  171. 2470 RETURN
  172. 2480 '********** DeclPart
  173. 2490 IF T=ID THEN T1$=ID$:K1=5:GOSUB 2560:GOTO 2540
  174. 2500 IF T=KPROC THEN GOSUB 1400:GOSUB 2010:GOTO 2540
  175. 2510 IF T=KFUNC THEN GOSUB 1400:GOSUB 2340:GOTO 2540
  176. 2520 IF T=KPRAGMA THEN GOSUB 2770:GOTO 2550
  177. 2530 E=3:GOTO 5020
  178. 2540 GOSUB 3420
  179. 2550 IF INSTR(DECLPART$,TT$) THEN 2480 ELSE GOSUB 4990:RETURN
  180. 2560 '********** ObjDecl
  181. 2570 GOSUB 1400
  182. 2580 IF T=COMMA THEN GOSUB 1400:T0=ID:GOSUB 1950:T1$=T1$+ID$:GOTO 2570
  183. 2590 T0=COLON:GOSUB 1960
  184. 2600 IF T=KCONST THEN 2650
  185. 2610 IF T=KARRAY THEN 2700
  186. 2620 GOSUB 2250:OBJSIZE=OBJSZ
  187. 2630 PINFO=0:KIND=K1:WHILE LEN(T1$)>0:ID$=LEFT$(T1$,8):T1$=MID$(T1$,9):ADDR=OFST:OFST=OFST+OBJSIZE:GOSUB 3850:WEND
  188. 2640 RETURN
  189. 2650 '********** Constant
  190. 2670 K1=0:OBJSIZE=0:GOSUB 1400:T0=COLONEQ:GOSUB 1960:IF T=ID THEN GOSUB 3890:GOTO 2690 ELSE IF T=SUBT THEN T1=-1:GOSUB 1400 ELSE T1=1
  191. 2680 CONST=TN*T1:IF T=C THEN TYPE=1 ELSE TYPE=2
  192. 2690 GOSUB 1400:GOTO 2630
  193. 2700 '********** Array
  194. 2710 K1=1:GOSUB 1400:T0=LP:GOSUB 1960:T2=TN:GOSUB 2290:T0=RP:GOSUB 1960:T0=KOF:GOSUB 1960
  195. 2750 GOSUB 2250:CONST=T2:OBJSIZE=(T2+1)*OBJSZ:IF T2<0 OR T2>16383 THEN E=15:GOTO 5020 ELSE 2630
  196. 2770 '********** Pragma
  197. 2780 IF T<>KPRAGMA THEN RETURN ELSE GOSUB 4830:GOSUB 1280:GOSUB 1400:GOTO 2780
  198. 2790 '********** Stmt
  199. 2800 T0=KBEGIN:GOSUB 1960:GOSUB 2810:T0=KEND:GOSUB 1960:RETURN
  200. 2810 '********** SeqOfStmts
  201. 2820 I=INSTR(STMT$,TT$)
  202. 2825 IF I=0 THEN RETURN ELSE ON I GOSUB 4320,4320,4320,2850,2850,2890,2930,2970,4630,2830,3440,2770:GOTO 2820
  203. 2830 '********** Null
  204. 2840 GOSUB 1400:GOSUB 3420:RETURN
  205. 2850 '********** Block
  206. 2860 X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 5400:IF T=KDECLARE THEN GOSUB 1400:GOSUB 2480
  207. 2880 GOSUB 2790:GOSUB 5500:GOSUB 5700:GOSUB 4300:OFST=X:GOSUB 3420:RETURN
  208. 2890 '********** Exit
  209. 2900 IF LPFLG=0 THEN E=14:GOTO 5020
  210. 2910 GOSUB 1400:IF T=SEMICOLON THEN W=PUJP:GOSUB 3990:GOTO 2925
  211. 2920 T0=KWHEN:GOSUB 1960:GOSUB 3100:GOSUB 4930:W=PNOT:GOSUB 3990:W=PFJP:GOSUB 3990
  212. 2925 W=XITJP:XITJP=CP:GOSUB 4030:GOSUB 3420:RETURN
  213. 2930 '********** Return
  214. 2940 GOSUB 1400
  215. 2950 IF T<>SEMICOLON THEN GOSUB 3100:TSP=TSP-1:W=PRNP ELSE W=PRET
  216. 2960 GOSUB 3990:GOSUB 3420:RETURN
  217. 2970 '********** If
  218. 2980 LUJP=0
  219. 2990 GOSUB 1400:GOSUB 3100:GOSUB 4930:W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:X=LUJP:GOSUB 4280
  220. 2995 T0=KTHEN:GOSUB 1960:GOSUB 2810:GOSUB 4300:LUJP=X
  221. 3000 IF T=KEND THEN GOSUB 3040:GOTO 3030
  222. 3010 IF T=KELSEIF THEN GOSUB 3060:GOSUB 3040:GOTO 2990
  223. 3020 T0=KELSE:GOSUB 1960:GOSUB 3060:GOSUB 3040:X=LUJP:GOSUB 4280:GOSUB 2810:GOSUB 4300:LUJP=X
  224. 3030 T0=KEND:GOSUB 1960:T0=KIF:GOSUB 1960:GOSUB 3080:GOSUB 3420:RETURN
  225. 3040 '********** Fix FJP
  226. 3050 GOSUB 4300:T1=CP:CP=X:W=T1-X-2:GOSUB 4030:CP=T1:RETURN
  227. 3060 '********** Gen UJP
  228. 3070 W=PUJP:GOSUB 3990:W=LUJP:LUJP=CP:GOSUB 4030:RETURN
  229. 3080 '********** Fixup
  230. 3090 T2=CP:WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
  231. 3100 '********** Expr
  232. 3110 GOSUB 3190:LFJP=0:PREV=0
  233. 3120 IF INSTR(LOGICALOP$,TT$)=0 THEN IF PREV THEN 3180 ELSE RETURN
  234. 3125 X=T:GOSUB 1400:IF (X=KAND AND T=KTHEN) THEN X=KAND+KTHEN ELSE IF (X=KOR AND T=KELSE) THEN X=KOR+KELSE
  235. 3130 IF PREV<>0 THEN IF PREV<>X THEN E=10:GOTO 5020
  236. 3140 IF X<>KAND AND X<>KOR THEN 3160
  237. 3145 GOSUB 4280:GOSUB 3190:IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
  238. 3147 TSP=TSP-1:GOSUB 4300:PREV=X:IF X=KAND THEN W=PAND ELSE W=POR
  239. 3150 GOSUB 3990:GOTO 3120
  240. 3160 GOSUB 4280:T1=X:W=PDUP:GOSUB 3990:IF T1=KAND+KTHEN THEN W=PFJP ELSE W=PNOT:GOSUB 3990:W=PFJP
  241. 3170 GOSUB 3990:W=LFJP:LFJP=CP:GOSUB 4030:GOSUB 1400:X=LFJP:GOSUB 4280:GOSUB 3190
  242. 3174 IF (TY(TSP)<>TBOL) OR (TY(TSP)<>TY(TSP-1)) THEN E=9:GOTO 5020
  243. 3175 TSP=TSP-1:GOSUB 4300:LFJP=X:GOSUB 4300:PREV=X:IF X=KAND+KTHEN THEN W=PAND ELSE W=POR
  244. 3178 GOSUB 3990:GOTO 3120
  245. 3180 T2=CP:WHILR LFJP<>0:CP=LFJP:GOSUB 4010:LFJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:RETURN
  246. 3190 '********** Relation
  247. 3200 GOSUB 3300
  248. 3210 IF INSTR(RELOP$,TT$)=0 THEN RETURN
  249. 3220 X=T:GOSUB 4280:GOSUB 1400
  250. 3230 GOSUB 3290:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR AND TY(TSP)<>TBOL THEN 3260
  251. 3235 IF TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
  252. 3240 GOSUB 4300:IF X=LES THEN W=PLESI ELSE IF X=LEQ THEN W=PLEQI ELSE IF X=GT THEN W=PGTRI
  253. 3245 IF X=GEQ THEN W=PGEQI ELSE IF X=EQ THEN W=PEQUI ELSE IF X=NEQ THEN W=PNEQI
  254. 3250 GOSUB 3990:GOTO 3210
  255. 3260 IF TY(TSP)<>TSTR OR TY(TSP)<>TY(TSP-1) THEN E=9:GOTO 5020 ELSE TSP=TSP-1:TY(TSP)=TBOL
  256. 3270 GOSUB 4300:IF X=LES THEN W=PLESSTR ELSE IF X=LEQ THEN W=PLEQSTR ELSE IF X=GT THEN W=PGTRSTR
  257. 3275 IF X=GEQ THEN W=PGEQSTR ELSE IF X=EQ THEN W=PEQUSTR ELSE IF X=NEQ THEN W=PNEQSTR
  258. 3280 GOSUB 3990:GOTO 3210
  259. 3290 '********** SE
  260. 3300 IF INSTR(UNARYOP$,TT$) THEN X=T:GOSUB 4280:X=1:GOSUB 4280:GOSUB 1400 ELSE X=0:GOSUB 4280
  261. 3310 GOSUB 3350:GOSUB 4300:IF X=1 THEN GOSUB 4300:IF X=SUBT THEN W=PNGI:GOSUB 3990 ELSE W=PNOT:GOSUB 3990
  262. 3320 IF INSTR(ADDOP$,TT$)=0 THEN RETURN
  263. 3330 X=T:GOSUB 4280:GOSUB 1400:GOSUB 3350:GOSUB 4300:IF X=ADD THEN W=PADI ELSE W=PSBI
  264. 3340 IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 3990:GOTO 3320
  265. 3350 '********** Term
  266. 3360 GOSUB 3610
  267. 3370 IF INSTR(MULOP$,TT$)=0 THEN RETURN
  268. 3380 X=T:GOSUB 4280:GOSUB 1400:GOSUB 3610
  269. 3390 IF TY(TSP)<>TY(TSP-1) OR (TY(TSP)<>TINT) THEN E=9:GOTO 5020 ELSE TSP=TSP-1
  270. 3400 GOSUB 4300:IF X=MUL THEN W=PMPI ELSE IF X=DIV THEN W=PDVI ELSE W=PMODI
  271. 3410 GOSUB 3990:GOTO 3370
  272. 3420 '********** Skip
  273. 3430 IF T=SEMICOLON THEN GOSUB 1400:RETURN ELSE E=13:GOSUB 5110:RETURN
  274. 3440 '********** ID
  275. 3450 GOSUB 3890:IF KIND<>2 THEN X=TYPE:GOSUB 4280:GOSUB 3490:GOTO 3530 ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
  276. 3460 GOSUB 1400:IF T=SEMICOLON THEN 3480 ELSE T0=LP:GOSUB 1960
  277. 3470 GOSUB 3570:T0=RP:GOSUB 1960
  278. 3480 GOSUB 4100:GOSUB 3420:RETURN
  279. 3490 GOSUB 4060:GOSUB 1400
  280. 3500 IF KIND<>1 THEN RETURN ELSE X=OBJSZ:GOSUB 4280
  281. 3510 T0=LP:GOSUB 1960:GOSUB 3100:GOSUB 4960:GOSUB 4300:IF X=2 THEN W=PIND ELSE W=PIXA:GOSUB 3990:W=X
  282. 3520 GOSUB 3990:T0=RP:GOSUB 1960:RETURN
  283. 3530 T0=COLONEQ:GOSUB 1960
  284. 3540 GOSUB 3100:GOSUB 4300:IF NOT (X=TY(TSP) OR (X=TINT AND TY(TSP)=TBOL) OR (X=TBOL AND TY(TSP)=TINT)) THEN E=9:GOTO 5020
  285. 3550 IF X=TSTR THEN W=PSAS ELSE W=PSTO
  286. 3560 TSP=TSP-1:GOSUB 3990:GOSUB 3420:RETURN
  287. 3570 '********** ActualParam
  288. 3580 IF T=AT THEN GOSUB 1400:T0=ID:GOSUB 1950:GOSUB 3890:GOSUB 3490 ELSE GOSUB 3100:TSP=TSP-1
  289. 3590 IF T=COMMA THEN GOSUB 1400:GOTO 3580
  290. 3600 RETURN
  291. 3610 '********** Primary
  292. 3620 IF T=LP THEN GOSUB 1400:GOSUB 3100:T0=RP:GOSUB 1960:RETURN
  293. 3630 IF T=C THEN TSP=TSP+1:TY(TSP)=TINT:GOSUB 3640:GOSUB 1400:RETURN
  294. 3633 IF T=CH THEN TSP=TSP+1:TY(TSP)=TCHR:GOSUB 3640:GOSUB 1400:RETURN ELSE 3650
  295. 3635 '********** LD Cons
  296. 3640 IF TN=-1 THEN W=PSLDCN1:GOTO 3645 ELSE IF TN>-1 AND TN<16 THEN W=64+TN:GOTO 3645
  297. 3643 IF TN>0 AND TN<256 THEN W=PSLDC:GOSUB 3990:W=TN:GOSUB 3990:RETURN ELSE W=PLDCI:GOSUB 3990:W=TN:GOSUB 4030:RETURN
  298. 3645 GOSUB 3990:RETURN
  299. 3650 IF T<>SC THEN 3670 ELSE TSP=TSP+1:TY(TSP)=TSTR
  300. 3660 W=PLCA:GOSUB 3990:W=LEN(S$):GOSUB 3990:FOR I=1 TO LEN(S$):W=ASC(MID$(S$,I)):GOSUB 3990:NEXT I:GOSUB 1400:RETURN
  301. 3670 T0=ID:GOSUB 1950
  302. 3680 GOSUB 3890:IF KIND=0 THEN TSP=TSP+1:TY(TSP)=TYPE:TN=CONST:GOSUB 3640:GOSUB 1400:RETURN
  303. 3682 GOSUB 1400:IF T=SQUOTE THEN 3780
  304. 3685 IF KIND=4 THEN X=TYPE:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100:T0=RP:GOSUB 1960:GOSUB 4300:TY(TSP)=X:RETURN
  305. 3690 TSP=TSP+1:TY(TSP)=TYPE:IF TYPE=0 THEN 3800
  306. 3700 IF KIND<>1 THEN 3740 ELSE GOSUB 4060
  307. 3710 T0=LP:GOSUB 1960
  308. 3720 GOSUB 3100:IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:W=PIND:GOSUB 3990:W=PSINDO:GOSUB 3990
  309. 3730 T0=RP:GOSUB 1960:RETURN
  310. 3740 IF KIND<>3 THEN GOSUB 3760:RETURN ELSE X=ADDR:GOSUB 4280:X=LEX:GOSUB 4280
  311. 3745 IF T=LP THEN GOSUB 1400:GOSUB 3570:T0=RP:GOSUB 1960
  312. 3750 GOSUB 4100:RETURN
  313. 3760 GOSUB 3820:IF PINFO=2 THEN W=PSINDO:GOSUB 3990
  314. 3770 RETURN
  315. 3780 TSP=TSP+1:TY(TSP)=TINT:GOSUB 1400:IF T=KLAST THEN W=PLDCI:GOSUB 3990:W=CONST:GOSUB 4030:GOTO 3790
  316. 3785 IF T=KLEN THEN GOSUB 4060:W=PLDB:GOSUB 3990 ELSE E=7:GOTO 5020
  317. 3790 GOSUB 1400:RETURN
  318. 3800 IF KIND<>1 THEN 3810 ELSE GOSUB 4060:X=OBJSZ:GOSUB 4280:T0=LP:GOSUB 1960:GOSUB 3100
  319. 3805 IF TY(TSP)<>TINT THEN E=9:GOTO 5020 ELSE TSP=TSP-1:GOSUB 4300:W=PIXA:GOSUB 3990:W=X:GOSUB 3990:T0=RP:GOSUB 1960:RETURN
  320. 3810 GOSUB 4060:RETURN
  321. 3820 '********** LD Val
  322. 3830 IF LEX=1 THEN 3831 ELSE IF LEX=LL THEN 3834 ELSE W=PLOD:GOSUB 3990:W=LL-LEX:GOTO 3845
  323. 3831 '********** Global
  324. 3832 IF ADDR<256 THEN W=PSLDO:GOTO 3840 ELSE W=PLDO:GOTO 3845
  325. 3834 '********** LDL
  326. 3835 IF ADDR>=0 AND ADDR<8 THEN W=PSLDLO+ADDR:GOSUB 3990:RETURN
  327. 3836 IF ADDR>0 AND ADDR<8 THEN W=PSLDL:GOTO 3840 ELSE W=PLDL:GOTO 3845
  328. 3840 '********** B,B
  329. 3842 GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
  330. 3845 '********** B,W
  331. 3847 GOSUB 3990:W=ADDR:GOSUB 4030:RETURN
  332. 3850 '********** Add ID
  333. 3860 IF LEN(S$(SSP))+17>255 THEN SSP=SSP+1
  334. 3870 S$(SSP)=ID$+CHR$(TYPE)+CHR$(KIND)+CHR$(PINFO)+MKI$(CONST)+CHR$(OBJSZ)+MKI$(ADDR)+CHR$(LL)+S$(SSP)
  335. 3880 RETURN
  336. 3890 '********** Lookup ID
  337. 3900 LOC1=SSP
  338. 3910 LOC2=INSTR(S$(LOC1),ID$):IF LOC2 THEN 3920 ELSE LOC1=LOC1-1:IF LOC1 THEN 3910 ELSE E=2::GOTO 5020
  339. 3920 T9=VARPTR(S$(LOC1)):POKE VLOC,PEEK(T9+1):POKE VLOC1,PEEK(T9+2):T9=V+LOC2-1
  340. 3930 TYPE=PEEK(T9+8):KIND=PEEK(T9+9):PINFO=PEEK(T9+10):POKE VLOC,PEEK(T9+11):POKE VLOC1,PEEK(T9+12):CONST=V
  341. 3960 OBJSZ=PEEK(T9+13):LEX=PEEK(T9+16):POKE VLOC,PEEK(T9+14):POKE VLOC1,PEEK(T9+15):ADDR=V:RETURN
  342. 3990 '********** GenByte
  343. 4000 GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:LSET D$=CHR$(W):CP=CP+1:RETURN
  344. 4010 '********** read wrd
  345. 4020 T1=CP:GOSUB 4260:POKE VLOC,W:CP=CP+1:GOSUB 4260:POKE VLOC1,W:W=V:CP=T1:RETURN
  346. 4030 '********** GenWord W
  347. 4040 GOSUB 4140:IF R2<127 THEN FIELD #1,R2 AS D$,2 AS D$:LSET D$=MKI$(W):CP=CP+2:RETURN
  348. 4050 V=W:W=PEEK(VLOC):GOSUB 3990:W=PEEK(VLOC1):GOSUB 3990:RETURN
  349. 4060 '********** LD Adr
  350. 4070 IF PINFO=2 THEN GOSUB 3820 RETURN
  351. 4080 IF LEX=1 THEN 4085 ELSE IF LEX=LL THEN 4090 ELSE W=PLDA:GOSUB 3990:W=LL-LEX:GOTO 3845
  352. 4085 '********** GL Adr
  353. 4087 IF ADDR<256 THEN W=PSLAO:GOTO 3840 ELSE W=PLAO:GOTO 3845
  354. 4090 '********** LDL Adr
  355. 4095 IF ADDR>=0 AND ADDR<256 THEN W=PSLLA:GOTO 3840 ELSE W=PLLA:GOTO 3845
  356. 4100 '********** Call Proc
  357. 4110 GOSUB 4300:LEX=X:GOSUB 4300:ADDR=X
  358. 4120 IF LEX=0 THEN W=PCSP ELSE IF LEX=2 THEN W=PCGP ELSE IF LEX=LL+1 THEN W=PCLP ELSE W=PCIP
  359. 4130 GOSUB 3990:W=ADDR:GOSUB 3990:RETURN
  360. 4140 '********** GetBuf
  361. 4150 T9=CP+CB:R1=T9\128+1:R2=T9 AND 127:IF R1=R0 THEN RETURN
  362. 4160 FIELD #1,128 AS D$:J=1
  363. 4170 IF B(J)=R0 OR B(J)=0 THEN 4190 ELSE J=J+1:IF J<=MB THEN 4170
  364. 4180 LSET B$(0)=D$:J=INT(RND*MB)+1:LSET D$=B$(J):PUT #1,B(J):LSET B$(J)=B$(0):B(J)=R0:GOTO 4200
  365. 4190 LSET B$(J)=D$:B(J)=R0
  366. 4200 J=1
  367. 4210 IF B(J)=R1 THEN 4240 ELSE J=J+1:IF J<=MB THEN 4210
  368. 4220 GET #1,R1:R0=R1:IF R1>M0 THEN M0=R1
  369. 4230 RETURN
  370. 4240 LSET D$=B$(J):R0=R1:IF R1>M0 THEN M0=R1
  371. 4250 RETURN
  372. 4260 '********** ReadByte
  373. 4270 GOSUB 4140:FIELD #1,R2 AS D$,1 AS D$:W=ASC(D$):RETURN
  374. 4280 '********** Push
  375. 4290 S(SP)=X:SP=SP+1:RETURN
  376. 4300 '********** Pop
  377. 4310 SP=SP-1:X=S(SP):RETURN
  378. 4320 '********** Loop
  379. 4330 IF T<>KWHILE THEN 4370
  380. 4340 GOSUB 1400:X=CP:GOSUB 4280:GOSUB 3100:GOSUB 4930
  381. 4350 W=PFJP:GOSUB 3990:X=CP:GOSUB 4280:W=0:GOSUB 4030:GOSUB 4590:GOSUB 4300
  382. 4360 T1=CP:CP=X:W=T1-X+1:GOSUB 4030:CP=T1:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
  383. 4370 IF T<>KFOR THEN 4580
  384. 4380 GOSUB 1400:T0=ID:GOSUB 1950:X=OFST:GOSUB 4280:GOSUB 5400
  385. 4390 ADDR=OFST:TYPE=1:KIND=5:PINFO=0:GOSUB 3850
  386. 4400 GOSUB 1400:T0=KIN:GOSUB 1960
  387. 4410 IF T=KREVERSE THEN X=-1:GOSUB 1400 ELSE X=1
  388. 4420 GOSUB 4280:W=PLLA:GOSUB 3990:W=OFST:GOSUB 4030
  389. 4430 GOSUB 3290:GOSUB 4960:W=PSTO:GOSUB 3990
  390. 4440 X=CP:GOSUB 4280:W=PLDL:GOSUB 3990:W=OFST:GOSUB 4030
  391. 4450 T0=DOTDOT:GOSUB 1960:GOSUB 3290:GOSUB 4960
  392. 4460 GOSUB 4300:T1=X:GOSUB 4300:IF X<0 THEN W=PGEQI ELSE W=PLEQI
  393. 4470 GOSUB 3990:W=PFJP:GOSUB 3990:GOSUB 4280:X=T1:GOSUB 4280
  394. 4480 X=CP:GOSUB 4280:W=0:GOSUB 4030:X=OFST:GOSUB 4280:OFST=OFST+2:GOSUB 4990
  395. 4490 GOSUB 4590:GOSUB 4300:T3=X:GOSUB 4300:T1=X:GOSUB 4300:T2=X:GOSUB 4300:IF X<0 THEN W=PDECL ELSE W=PINCL
  396. 4500 GOSUB 3990:W=T3:GOSUB 4030
  397. 4520 W=PUJP:GOSUB 3990
  398. 4530 W=T2-CP-2:GOSUB 4030:T2=CP:CP=T1:W=T2-T1-2:GOSUB 4030:CP=T2
  399. 4550 GOSUB 5500:GOSUB 5700
  400. 4560 GOSUB 4300:OFST=X
  401. 4570 GOSUB 4620:RETURN
  402. 4580 X=CP:GOSUB 4280:GOSUB 4590:W=PUJP:GOSUB 3990:GOSUB 4300:W=X-CP-2:GOSUB 4030:GOSUB 4620:RETURN
  403. 4590 T0=KLOOP:GOSUB 1960:X=XITJP:GOSUB 4280:XITJP=0:X=LPFLG:GOSUB 4280:LPFLG=-1:GOSUB 2810
  404. 4600 T0=KEND:GOSUB 1960
  405. 4610 T0=KLOOP:GOSUB 1960:GOSUB 4300:T5=X:GOSUB 4300:T6=X:GOSUB 3420:RETURN
  406. 4620 T2=CP:WHILE XITJP<>0:CP=XITJP:GOSUB 4010:XITJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2:LPFLG=T5:XITJP=T6:RETURN
  407. 4630 '********** Case
  408. 4640 GOSUB 1400:GOSUB 3100:IF TY(TSP)<>TINT AND TY(TSP)<>TCHR THEN E=9:GOTO 5020
  409. 4645 TSP=TSP-1:W=PXJP:GOSUB 3990:X=CP:GOSUB 4280:GOSUB 4030:GOSUB 4030:GOSUB 4030:CASES=0:LUJP=0:T0=KIS:GOSUB 1960
  410. 4650 T0=KWHEN:GOSUB 1960:IF T=KOTHERS THEN 4810 ELSE T1=0
  411. 4660 IF T=ID THEN GOSUB 3890:TN=CONST:IF TYPE=1 OR TYPE=2 THEN T=C
  412. 4670 IF T<>CH AND T<>C THEN E=5:GOTO 5020 ELSE X=TN:GOSUB 4280:T1=T1+1:GOSUB 1400:IF T=BAR THEN GOSUB 1400:GOTO 4660
  413. 4680 GOSUB 4780
  414. 4690 IF T=KWHEN THEN 4650 ELSE X=0:GOSUB 4280:GOSUB 4280:X=1:GOSUB 4280:CASES=CASES+1
  415. 4700 T0=KEND:GOSUB 1960:T0=KCASE:GOSUB 1960
  416. 4710 T1=SP-4:T3=32767:T4=-32767:FOR I=1 TO CASES-1:T2=S(T1):T1=T1-2:FOR J=1 TO T2:IF S(T1)<T3 THEN T3=S(T1)
  417. 4715 IF S(T1)>T4 THEN T4=S(T1)
  418. 4720 T1=T1-1:NEXT J:NEXT I:W=PUJP:GOSUB 3990:T5=CP:GOSUB 4300:GOSUB 4300:T1=X:GOSUB 4300
  419. 4725 IF X=-1 THEN W=T1-CP-2:GOSUB 4030 ELSE W=LUJP:LUJP=CP:GOSUB 4030
  420. 4730 FOR I=T3 TO T4:W=T5-CP-3:GOSUB 4030:NEXT I '*** build table
  421. 4740 T7=CP:FOR I=1 TO CASES-1:GOSUB 4300:T2=X:GOSUB 4300:T6=X:FOR T8=1 TO T2:GOSUB 4300
  422. 4745 CP=T5+(X-T3)*2+2:W=T6-CP-2:GOSUB 4030:NEXT T8:NEXT I:CP=T7
  423. 4750 GOSUB 4300:T2=CP:CP=X:W=T3:GOSUB 4030:W=T4:GOSUB 4030:W=T5-CP-2:GOSUB 4030
  424. 4760 WHILE LUJP<>0:CP=LUJP:GOSUB 4010:LUJP=W:W=T2-CP-2:GOSUB 4030:WEND:CP=T2
  425. 4770 GOSUB 3420:RETURN
  426. 4780 T0=EQGT:GOSUB 1960:X=CP:GOSUB 4280:X=T1:GOSUB 4280:X=LUJP:GOSUB 4280:CASES=CASES+1:X=CASES:GOSUB 4280:GOSUB 2810
  427. 4790 W=PUJP:GOSUB 3990:GOSUB 4300:CASES=X:GOSUB 4300:LUJP=X
  428. 4800 W=LUJP:LUJP=CP:GOSUB 4030:RETURN
  429. 4810 '********** Others
  430. 4820 GOSUB 1400:X=-1:GOSUB 4280:T1=1:GOSUB 4780:GOTO 4700
  431. 4830 '********** Pragma
  432. 4840 GOSUB 1400:IF S$<>"LIST" THEN 4850
  433. 4845 GOSUB 4880:IF T$="ON" THEN PLST=-1:LPRINT LP$;:RETURN ELSE IF T$="OFF" THEN PLST=0:RETURN ELSE E=6:GOTO 5020
  434. 4850 IF S$="CRT" THEN GOSUB 4880:IF T$="ON" THEN CLST=-1:RETURN ELSE CLST=0:RETURN
  435. 4860 IF S$<>"INCLUDE" THEN RETURN ELSE GOSUB 1400:T0=LP:GOSUB 1960
  436. 4870 IF T<>SC THEN E=9:GOTO 5020 ELSE GOSUB 1230:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
  437. 4880 GOSUB 1400:T0=LP:GOSUB 1960:T$=S$:GOSUB 1400:T0=RP:GOSUB 1960:RETURN
  438. 4910 '********** WriteProc
  439. 4920 T2=CP:T3=CB:CB=0:CP=(ADDR-1)*7+128:W=C1-1920:GOSUB 4030:W=L1:GOSUB 4030:W=P1:GOSUB 4030:W=LL:GOSUB 3990:CP=T2:CB=T3:RETURN
  440. 4930 '********** Check Bool
  441. 4940 IF TY(TSP)<>TBOL THEN E=9:GOTO 5020
  442. 4950 TSP=TSP-1:RETURN
  443. 4960 '********** Check Int
  444. 4970 IF TY(TSP)<>TINT THEN E=9:GOTO 5020
  445. 4980 TSP=TSP-1:RETURN
  446. 4990 '********** Max Offst
  447. 5000 IF OFST>MXOF THEN MXOF=OFST
  448. 5010 RETURN
  449. 5020 GOSUB 5100:STOP
  450. 5100 PRINT:PRINT"*** Error";E;" in line";LN:PRINT BUF$:PRINT TAB(B-1);"*":RETURN
  451. 5110 PRINT:PRINT T0;" expected":GOSUB 5100:RETURN
  452. 5200 '********** Proc DEF
  453. 5210 LL=LL+1:X=CPROC:GOSUB 4280:X=OFST:GOSUB 4280:X=MXOF:GOSUB 4280:T0=ID:GOSUB 1950
  454. 5220 GOSUB 5400:RETURN
  455. 5300 '********** Proc END DEF
  456. 5310 W=PEOP:GOSUB 3990:GOSUB 4300:P1=X:GOSUB 4300:ADDR=X:CPROC=X:L1=MXOF:C1=GC:GOSUB 4910:GC=GC+CP
  457. 5320 LL=LL-1:GOSUB 5500:GOSUB 5600
  458. 5330 GOSUB 4300:MXOF=X:GOSUB 4300:OFST=X:GOSUB 4300:CPROC=X:RETURN
  459. 5400 '********** Push Syms
  460. 5410 X=LEN(S$(SSP)):IF X=255 THEN SSP=SSP+1:X=0
  461. 5420 GOSUB 4280:X=SSP:GOSUB 4280:RETURN
  462. 5500 '********** Pop Syms
  463. 5510 GOSUB 4300:FOR I=X+1 TO SSP:S$(I)="":NEXT I:SSP=X:GOSUB 4300:LOC2=X:RETURN
  464. 5520 RETURN
  465. 5600 S$(SSP)=RIGHT$(S$(SSP),LOC2+17):RETURN
  466. 5700 S$(SSP)=RIGHT$(S$(SSP),LOC2):RETURN
  467. 32767 KEY ON: END
  468.